{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  ContML.CPS
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax of CPS language.
--
--------------------------------------------------------------------------------


module ContML.CPS
  ( 

    Val(..)
  , Term(..)
  , FunDef(..)
  , ContDef(..)

  , ppTerm

  ) where


import ContML.VarId

import Text.PrettyExprHPJ.MosML                 -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ                -- package: pretty

type CVar = VarId

data Val = Unit
         | Int Int
         | Pair VarId VarId
         | Tag Int VarId
         | Abs CVar VarId Term
  deriving (Eq,Show)

data Term = LetVal VarId Val Term
          | LetProj VarId Int VarId Term
          | LetCont [ContDef] Term
          | LetFun [FunDef] Term
          | AppCont CVar VarId
          | App VarId CVar CVar VarId
          | Case VarId CVar CVar          
  deriving (Eq,Show)  

data FunDef = FunDef VarId VarId VarId VarId Term
  deriving (Eq,Show)

data ContDef = ContDef VarId VarId Term
  deriving (Eq,Show)


ppVar :: VarId -> Doc
ppVar = text . var_name

ppVal :: Val -> Doc
ppVal (Unit)                        = text "()"
ppVal (Int i)                       = int i
ppVal (Pair x y)                    = parens (ppVar x <> comma <> ppVar y)
ppVal (Tag i x)                     = text "in" <> int i <+> ppVar x
ppVal (Abs k x v)                   = 
   char '\\' <> ppVar k <+> ppVar x <+> text "->" <+> ppTerm v


ppTerm :: Term -> Doc
ppTerm = unparse . termDoc


termDoc :: Term -> DocE
termDoc (LetVal x v k)              =
    Atom $ text "letval" <+> ppVar x <+> equals <+> ppVal v 
                         $+$ text "in" <+> ppTerm k

termDoc (LetProj x i z k)           = 
    Atom $ text "let" <+> ppVar x <+> text "pi" <> int i <+> ppVar z 
                      $+$ text "in" <+> ppTerm k

termDoc (LetCont ks l)              = 
    Atom $ text "letcont" <+> (vcat $ map ppContDef ks) 
                          $+$ text "in" <+> ppTerm l

termDoc (LetFun ds l)               = 
    Atom $ text "letfun" <+> (vcat $ map ppFunDef ds) 
                         $+$ text "in" <+> ppTerm l

termDoc (AppCont k x)               =
    funAppB1 (Atom $ ppVar k) (Atom $ ppVar x)

termDoc (App f k h x)               = 
    funAppB (Atom $ ppVar f) (map (Atom . ppVar) [k,h,x])

termDoc (Case x k1 k2)              = 
    Atom $ text "case" <+> ppVar x  <+> text "of" 
                       <+> ppVar k1 <+> text "||" <+> ppVar k2




ppFunDef :: FunDef -> Doc
ppFunDef (FunDef f k h x tm)        = 
    ppVar f <+> ppVar k <+> ppVar h <+> ppVar x <+> char '=' <+> ppTerm tm


ppContDef :: ContDef -> Doc
ppContDef (ContDef k x tm)        = 
    ppVar k <+> ppVar x <+> char '=' <+> ppTerm tm

